home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / virtual.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  9.3 KB  |  247 lines
  1. ;;; -*- mode:lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;;
  20. ;;; Change history:
  21. ;;;
  22. ;;;  Date    Author    Description
  23. ;;; -------------------------------------------------------------------------------------
  24. ;;; 10/14/87    LGO    Created
  25.  
  26. (in-package 'cluei :use '(lisp xlib))
  27.  
  28. (export '( virtual
  29.       virtual-composite
  30.       ))
  31.  
  32. ;; These are methods that duplicate the xlib draw-rectangle, draw-rectangle and clear-area
  33. ;; functions.  I'm not happy with the names, please mail suggestions to clue-review@dsg.csc.ti.com
  34. (export '(rectangle glyphs clear))
  35.  
  36. (defcontact virtual (basic-contact)
  37.   ()
  38.   (:documentation "A contact without a window")
  39.   )
  40.  
  41. (defmethod (setf contact-state) (state (contact virtual))
  42.   (check-type state (member :withdrawn :managed :mapped))
  43.   (let ((old-state (slot-value (the contact contact) 'state)))
  44.     (unless (eq old-state state)
  45.       (setf (slot-value (the contact contact) 'state) state))))
  46.  
  47. (defmethod realize ((contact virtual))
  48.   ;; Create the Window for CONTACT.
  49.   ;; This is a method to allow contacts to specialize the options.
  50.   ;; Applications should call PRESENT
  51.   ;;
  52.   ;; Ensure the parent is realized
  53.   (with-slots (parent) contact
  54.     (unless (realized-p parent)
  55.       (realize parent)))
  56.   ;; Use the PARENT's window
  57.   (setf (window-id contact) (window-id (contact-parent contact))))
  58.  
  59. (defmethod destroy ((contact virtual))
  60.   ;; Destroy a contact and all its resources
  61.   (when (and (realized-p contact)      ;; only destroy realized windows once
  62.          (contact-parent contact))   ;; Don't destroy screen
  63.     (setf (contact-state contact) :withdrawn)
  64.     (setf (window-id contact) -1)))
  65.  
  66. (defmethod accept-focus-p ((contact virtual))
  67.   "Returns non-nil when CONTACT is willing to become the keyboard input focus"
  68.   nil)
  69.  
  70. (defmethod move ((contact virtual) x y)
  71.   (with-slots ((contact-x x) (contact-y y)) contact
  72.     (setf contact-x x)
  73.     (setf contact-y y)))
  74.   
  75. (defmethod resize ((contact virtual) width height border-width)
  76.   (with-slots ((contact-width width)
  77.            (contact-height height)
  78.            (contact-border-width border-width)) contact
  79.     (setf contact-width width)
  80.     (setf contact-height height)
  81.     (setf contact-border-width border-width)))
  82.  
  83. (defmethod inside-contact-p ((contact virtual) x y)
  84.   ;; Returns T when x/y (relative to parent) is inside or on contact"
  85.   (with-slots ((contact-x x)
  86.            (contact-y y)
  87.            (contact-width width)
  88.            (contact-height height)) contact
  89.     (and (< 0 (- x contact-x) contact-width)
  90.      (< 0 (- y contact-y) contact-height))))
  91.  
  92. (defmethod rectangle ((contact virtual) gcontext x y width height &optional fill-p)
  93.   (with-slots ((contact-x x)
  94.            (contact-y y)) contact
  95.     (draw-rectangle contact gcontext (+ x contact-x) (+ y contact-y) width height fill-p)))
  96.  
  97. (defmethod glyphs ((contact virtual) gcontext x y sequence &rest options)
  98.   (with-slots ((contact-x x) (contact-y y)) contact
  99.     (apply #'draw-glyphs contact gcontext (+ x contact-x) (+ y contact-y) sequence options)))
  100.  
  101. (defmethod clear ((contact virtual) &key (x 0) (y 0) width height exposures-p)
  102.   (with-slots ((contact-x x)
  103.            (contact-y y)
  104.            (contact-width width)
  105.            (contact-height height)) contact
  106.     (clear-area contact :x (+ x contact-x) :y (+ y contact-y)
  107.         :width (or width contact-width) :height (or height contact-height)
  108.         :exposures-p exposures-p)))
  109.  
  110. ;;-----------------------------------------------------------------------------
  111.  
  112. (defcontact virtual-composite (composite)
  113.   ((mouse-contact :type (or null virtual) :accessor mouse-contact) ;; Set to the virtual window the mouse is in
  114.    )
  115.   (:documentation "A composite contact that may have virtual children")
  116.   )
  117.  
  118. (defmethod realize :before ((contact virtual-composite))
  119.   (with-slots ((composite-event-mask event-mask)) contact
  120.     (let ((event-mask 0))
  121.       ;; Combine the event masks for the virtual children
  122.       (dolist (child (composite-children contact))
  123.     (when (typep child 'virtual)
  124.       (setq event-mask (logior event-mask (contact-event-mask child)))))
  125.       ;; Select pointer-motion when enter/leave window is needed
  126.       (when (plusp (logand event-mask #.(make-event-mask :enter-window :leave-window)))
  127.     (setq event-mask (logior event-mask #.(make-event-mask :pointer-motion))))
  128.       ;; Combine virtual event mask with the composite's
  129.       (setf composite-event-mask (logior event-mask composite-event-mask)))))
  130.  
  131. (defmethod handle-event ((contact virtual-composite) event)
  132.   ;; Do event/callback translation based on the event-translations slot
  133.   (declare (type contact contact)
  134.        (type event event))
  135.   (labels ((event-child (event)
  136.          (let ((x (slot-value (the event event) 'x))
  137.            (y (slot-value (the event event) 'y)))
  138.            (dolist (child (composite-children contact))
  139.          (when (and (typep child 'virtual)
  140.                 (inside-contact-p child x y))
  141.            (return child))))))
  142.     
  143.     (block exit
  144.       (let ((event-key (slot-value (the event event) 'key))
  145.         (event-sequence (slot-value (the event event) 'sequence)))
  146.     ;; Handle universal events
  147.     (case event-key
  148.       ;; Forward events to virtual children
  149.       ((:key-press :key-release :button-press :button-release)
  150.        (let ((child (event-child event)))
  151.          (with-slots ((child-x x) (child-y y)
  152.               (child-event-mask event-mask)) (the virtual child)
  153.            (with-slots ((event-x x) (event-y y)
  154.                 (event-key key)) (the event event)
  155.          (when (and child
  156.                 (plusp
  157.                   (logand child-event-mask
  158.                       (case event-key
  159.                     (:key-press #.(make-event-mask :key-press))
  160.                     (:key-release #.(make-event-mask :key-release))
  161.                     (:button-press #.(make-event-mask :button-press))
  162.                     (:button-release #.(make-event-mask :button-release))))))
  163.            ;; Make event relative to child
  164.            (setf event-x (- event-x child-x)
  165.              event-y (- event-y child-y))
  166.            (cluei::dispatch-event event event-key t event-sequence child)
  167.            (return-from exit nil))))))
  168.       
  169.       ;; fabricate mouse enter/leave for virtual children
  170.       (:motion-notify
  171.        (let ((child (event-child event)))
  172.          (when child
  173.            (let ((mouse-contact (mouse-contact contact))
  174.              (handled-p nil)
  175.              (x (slot-value (the event event) 'x))
  176.              (y (slot-value (the event event) 'x)))
  177.          (with-slots ((child-x x) (child-y y)
  178.                   (child-event-mask event-mask)) (the virtual child)
  179.            (with-slots ((mouse-x x) (mouse-y y)
  180.                 (mouse-event-mask event-mask)) (the virtual mouse-contact)
  181.              (with-slots ((event-x x) (event-y y)
  182.                   (event-key key)) (the event event)
  183.                (when (and mouse-contact (not (eq mouse-contact child))
  184.                   (plusp (logand #.(make-event-mask :leave-window)
  185.                          mouse-event-mask)))
  186.              ;; Make event relative to child
  187.              (setf event-x (- x mouse-x)
  188.                    event-y (- y mouse-y))
  189.              (cluei::dispatch-event event :leave-notify t event-sequence mouse-contact)
  190.              (setq handled-p t))
  191.                (setf (mouse-contact contact) child)
  192.                (when (and (not (eq mouse-contact child))
  193.                   (plusp (logand #.(make-event-mask :enter-window)
  194.                          child-event-mask)))
  195.              (setf event-x (- x child-x)
  196.                    event-y (- y child-y))
  197.              (cluei::dispatch-event event :enter-notify t event-sequence child)
  198.              (setq handled-p t))
  199.                (when (plusp (logand #.(make-event-mask
  200.                         :pointer-motion :pointer-motion-hint
  201.                          :button-1-motion :button-2-motion :button-3-motion
  202.                         :button-4-motion :button-5-motion :button-motion)
  203.                         child-event-mask))
  204.              (setf event-x (- x child-x)
  205.                    event-y (- y child-y))
  206.              (cluei::dispatch-event event :motion-notify t event-sequence child)
  207.              (setq handled-p t))
  208.                (when handled-p (return-from exit nil))
  209.                (setf event-x x
  210.                  event-y y))))))))
  211.  
  212.       ;; When mouse leaves composite, fabricate leave-notify for virtual children
  213.       (:leave-notify
  214.        (let ((mouse-contact (mouse-contact contact)))
  215.          (with-slots ((mouse-x x) (mouse-y y)
  216.               (mouse-event-mask event-mask)) (the virtual mouse-contact)
  217.            (with-slots ((event-x x) (event-y y)
  218.                 (event-key key)) (the event event)
  219.          (when (and mouse-contact
  220.                 (plusp (logand #.(make-event-mask :leave-window)
  221.                        mouse-event-mask)))
  222.            ;; Make event relative to child
  223.            (setf event-x (- event-x mouse-x)
  224.              event-y (- event-y mouse-y))
  225.            (cluei::dispatch-event event :leave-notify t event-sequence mouse-contact)
  226.            (setf (mouse-contact contact) nil)
  227.            (return-from exit nil))))))
  228.  
  229.       (:exposure
  230.        (with-slots ((event-x x) (event-y y)
  231.             (event-height height)
  232.             (event-width width)) (the event event)
  233.          (let ((x event-x)
  234.            (y event-y))
  235.            (display contact x y event-width event-height)
  236.            (dolist (child (composite-children contact))
  237.          (when (typep child 'virtual)
  238.            (with-slots ((child-x x) (child-y y))
  239.                    (the virtual child)
  240.              (setf event-x (- x child-x)
  241.                event-y (- y child-y)))
  242.            (cluei::dispatch-event event :exposure t event-sequence child)))
  243.            (setf event-x x
  244.              event-y y)))))
  245.  
  246.     (call-next-method)
  247.     ))))